home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
- ;;;
- ;;; **********************************************************************
- ;;; This code was written as part of the CMU Common Lisp project at
- ;;; Carnegie Mellon University, and has been placed in the public domain.
- ;;; If you want to use this code or any part of CMU Common Lisp, please contact
- ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
- ;;;
- (ext:file-comment
- "$Header: commandline.lisp,v 1.2 91/02/08 13:31:31 ram Exp $")
- ;;;
- ;;; **********************************************************************
- ;;;
- ;;; Stuff to eat the command line passed to us from the shell.
- ;;; Written by Bill Chiles.
- ;;;
-
- (in-package "EXTENSIONS")
- (export '(*command-line-words* *command-line-switches*
- *command-switch-demons* *command-line-utility-name*
- *command-line-strings* cmd-switch-string command-line-switch-p
- cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch
- defswitch cmd-switch-arg get-command-line-switch))
-
- (defvar *command-line-switches* ()
- "A list of cmd-switch's representing the arguments used to invoke
- this process.")
-
- (defvar *command-line-utility-name* ""
- "The string name that was used to invoke this process.")
-
- (defvar *command-line-words* ()
- "A list of words between the utility name and the first switch.")
-
- (defvar *command-line-strings* ()
- "A list of strings obtained from the command line that invoked this process.")
-
- (defvar *command-switch-demons* ()
- "An Alist of (\"argument-name\" . demon-function)")
-
-
-
- (defstruct (command-line-switch (:conc-name cmd-switch-)
- (:constructor make-cmd-switch
- (name value words))
- (:print-function print-command-line-switch))
- name ;the name of the switch
- value ;the value of that switch
- words ;random words dangling between switches assigned to the
- ;preceeding switch
- )
-
- (defun print-command-line-switch (object stream n)
- (declare (ignore n))
- (write-string "#<Command Line Switch " stream)
- (prin1 (cmd-switch-name object) stream)
- (let ((value (cmd-switch-value object))
- (words (cmd-switch-words object)))
- (when (or value words) (write-string " -- " stream)
- (when value (prin1 value stream))
- (when words (prin1 words stream))))
- (write-string ">" stream))
-
-
-
- ;;;; Processing the command strings.
-
- (defun process-command-strings ()
- (setq *command-line-words* nil)
- (setq *command-line-switches* nil)
- (let ((cmd-strings lisp::lisp-command-line-list)
- str)
- (declare (special lisp::lisp-command-line-list))
- ;; Set some initial variables.
- ;;
- (setf *command-line-strings* (copy-list lisp::lisp-command-line-list))
- (setf *command-line-utility-name* (pop cmd-strings))
- (setq str (pop cmd-strings))
- ;; Set initial command line words.
- ;;
- (loop
- (unless str (return nil))
- (unless (zerop (length (the simple-string str)))
- (when (char= (schar str 0) #\-)
- (setq *command-line-words* (reverse *command-line-words*))
- (return nil))
- (push str *command-line-words*))
- (setq str (pop cmd-strings)))
- ;; Set command line switches.
- ;;
- (loop
- (unless str
- (return (setf *command-line-switches*
- (nreverse *command-line-switches*))))
- (let* ((position (position #\= (the simple-string str) :test #'char=))
- (switch (subseq (the simple-string str) 1 position))
- (value (if position
- (subseq (the simple-string str) (1+ position)
- (length (the simple-string str))))))
- (setq str (pop cmd-strings))
- ;; Set this switches words until the next switch.
- ;;
- (let (word-list)
- (loop
- (unless str
- (push (make-cmd-switch switch value (nreverse word-list))
- *command-line-switches*)
- (return nil))
- (unless (zerop (length (the simple-string str)))
- (when (char= #\- (schar str 0))
- (push (make-cmd-switch switch value (nreverse word-list))
- *command-line-switches*)
- (return nil))
- (push str word-list))
- (setq str (pop cmd-strings))))))))
-
- (defun get-command-line-switch (sname)
- "Accepts the name of a switch as a string and returns the value of the
- switch. If no value was specified, then any following words are returned.
- If there are no following words, then t is returned. If the switch was not
- specified, then nil is returned."
- (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname))
- (switch (find name *command-line-switches*
- :test #'string-equal
- :key #'cmd-switch-name)))
- (when switch
- (or (cmd-switch-value switch)
- (cmd-switch-words switch)
- T))))
-
-
-
- ;;;; Defining Switches and invoking demons.
-
- (defvar *complain-about-illegal-switches* t
- "When set, invoking switch demons complains about illegal switches that have
- not been defined with DEFSWITCH.")
-
- ;;; This is a list of legal switch names. DEFSWITCH sets this, and
- ;;; INVOKE-SWITCH-DEMONS makes sure all the switches it sees are on this
- ;;; list.
- ;;;
- (defvar *legal-cmd-line-switches* nil)
-
- ;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*. For
- ;;; each switch, it checks to see if there is a switch demon with the same
- ;;; name. If there is, then that demon is called as a function on the switch.
- ;;;
- (defun invoke-switch-demons (&optional (switches *command-line-switches*)
- (demons *command-switch-demons*))
- (dolist (switch switches t)
- (let* ((name (cmd-switch-name switch))
- (demon (cdr (assoc name demons :test #'string-equal))))
- (cond (demon (funcall demon switch))
- ((or (member name *legal-cmd-line-switches* :test #'string-equal)
- (not *complain-about-illegal-switches*)))
- (t (warn "~S is an illegal switch" switch))))))
-
- (defmacro defswitch (name &optional function)
- "Associates function with the switch name in *command-switch-demons*. Name
- is a simple-string that does not begin with a hyphen, unless the switch name
- really does begin with one. Function is optional, but defining the switch
- is necessary to keep invoking switch demons from complaining about illegal
- switches. This can be inhibited with *complain-about-illegal-switches*."
- (let ((gname (gensym))
- (gfunction (gensym)))
- `(let ((,gname ,name)
- (,gfunction ,function))
- (check-type ,gname simple-string)
- (check-type ,gfunction (or symbol function) "a symbol or function")
- (push ,gname *legal-cmd-line-switches*)
- (when ,gfunction
- (push (cons ,gname ,gfunction) *command-switch-demons*)))))
-
-
- (defun eval-switch-demon (switch)
- (eval (read-from-string (cmd-switch-arg switch))))
- (defswitch "eval" #'eval-switch-demon)
-
- (defun load-switch-demon (switch)
- (load (cmd-switch-arg switch)))
- (defswitch "load" #'load-switch-demon)
-
- (defun cmd-switch-arg (switch)
- (or (cmd-switch-value switch)
- (car (cmd-switch-words switch))
- (car *command-line-words*)))
-
- (defswitch "core")
- (defswitch "init")
- (defswitch "noinit")
- (defswitch "hinit")
-